{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.PostScript
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- PostScript syntax - one of the back ends.
--
--------------------------------------------------------------------------------

module WumpusExpr.PostScript
  (
    
    Program    
  , ppProgram
  
  , program
  ) where

import WumpusExpr.FreshMon
import qualified WumpusExpr.KNormal as K
import WumpusExpr.Operators
import WumpusExpr.Types
import WumpusExpr.Utils
import WumpusExpr.VarId


import Text.PrettyPrint.HughesPJ                -- package: pretty

import Control.Applicative




data Program = Program 
      { proc_main :: Fundef 
      , proc_defs :: [Fundef]
      }
  deriving (Eq,Show)


type VarName = String


-- | PostScript fundefs do not have explicit arguments.
-- Args are popped from the stack in the initial lines
-- of the procedure.
-- 
data Fundef = Fundef 
    { fun_name       :: VarId
    , fun_body       :: [Stmt]
    } 
  deriving (Eq, Show)


data Stmt = ArgDef  VarName             -- /a exch def
          | Command Command
          | IfElse  RelOp Expr Expr [Stmt] [Stmt]
  deriving (Eq,Show)



data Command = NewPath
             | ClosePath
             | Fill
             | Stroke
             | MoveTo Expr Expr
             | LineTo Expr Expr
             | CurveTo Expr Expr Expr Expr Expr Expr
             | GSave
             | GRestore
             | Scale Expr Expr
             | Rotate Expr
             | Translate Expr Expr
             | Transform Expr Expr Expr Expr Expr Expr
             | ShowText Expr
  deriving (Eq,Show)


-- | We still differentiate expressions (although they look the 
-- same as statements...) because we want expressions and only
-- expressions in the argument position of commands. 
--
data Expr = Val Value
          | UnaryE UnaryOp Expr
          | BinE BinOp Expr Expr
          | CondE RelOp Expr Expr Expr Expr
  deriving (Eq,Show)


data Value = Int Int
           | Float Decimal
           | String String
           | PsSymbol String
           | Var VarName
  deriving (Eq,Show)

--------------------------------------------------------------------------------
-- Pretty print

ppProgram :: Program -> Doc
ppProgram (Program main_proc defs) = 
    vcatBlank $ map ppFundef (defs ++ [main_proc])


ppFundef :: Fundef -> Doc
ppFundef (Fundef name e) = 
    text ('/': varName name) <+> braces (nest 2 (ppStmts e)) <+> text "def"


ppStmts :: [Stmt] -> Doc
ppStmts = vcat . map ppStmt

ppStmt :: Stmt -> Doc
ppStmt (ArgDef name)            = 
    psCommand "def" [ text ('/':name), text "exch" ]
 
ppStmt (Command cmd)            = ppCommand cmd
ppStmt (IfElse op e1 e2 s1 s2)  =
    psCommandV "ifelse" [ bool_expr, ppBlock s1, ppBlock s2 ]
  where
    ppBlock   = braceBlock 2 . map ppStmt
    bool_expr = ppRel op [ppExpr e1, ppExpr e2]

-- | Can pretty print directly as we are always postfix and do 
-- not need parens.
--
ppExpr :: Expr -> Doc
ppExpr (Val v)                  = ppValue v
ppExpr (UnaryE op e)            = ppUnary op [ppExpr e]
ppExpr (BinE op e1 e2)          = ppBinary op [ppExpr e1, ppExpr e2]
ppExpr (CondE op e1 e2 e3 e4)   = 
    psCommand "ifelse" [bool_expr, ppExpr e3, ppExpr e4]
  where
    bool_expr = ppRel op [ppExpr e1, ppExpr e2]
   


ppUnary :: UnaryOp -> [Doc] -> Doc
ppUnary NEG  = psCommand "neg"
ppUnary BNOT = psCommand "not"

ppBinary :: BinOp -> [Doc] -> Doc
ppBinary ADD        = psCommand "add"
ppBinary SUB        = psCommand "sub"
ppBinary MUL        = psCommand "mul"
ppBinary DIV        = psCommand "div"
ppBinary LOG_AND    = psCommand "and"
ppBinary LOG_OR     = psCommand "or"
ppBinary MOD        = psCommand "mod"

ppRel :: RelOp -> [Doc] -> Doc
ppRel EQU           = psCommand "eq"
ppRel NOT_EQU       = psCommand "neq"
ppRel LTHAN         = psCommand "lt"
ppRel GTHAN         = psCommand "gt"
ppRel LT_EQU        = psCommand "le"
ppRel GT_EQU        = psCommand "ge"

ppCommand :: Command -> Doc
ppCommand (NewPath)                     = psCommand "newpath" []
ppCommand (ClosePath)                   = psCommand "closepath" []
ppCommand (Fill)                        = psCommand "fill" []
ppCommand (Stroke)                      = psCommand "stroke" []
ppCommand (MoveTo x y)                  = 
    psCommand "moveto" $ map ppExpr [x,y]

ppCommand (LineTo x y)                  = 
    psCommand "lineto" $ map ppExpr [x,y]

ppCommand (CurveTo x1 y1 x2 y2 x3 y3)   = 
    psCommand "curveto" $ map ppExpr [x1,y1,x2,y2,x3,y3]

ppCommand (GSave)                       = psCommand "gsave" []
ppCommand (GRestore)                    = psCommand "grestore" []
ppCommand (Scale x y)                   =
    psCommand "scale" $ map ppExpr [x,y]

ppCommand (Rotate ang)                  = psCommand "rotate" [ppExpr ang]
ppCommand (Translate x y)               = 
    psCommand "translate" $ map ppExpr [x,y]

ppCommand (Transform a b c d e f)       =
    psCommand "transform" $ map ppExpr [a,b,c,d,e,f]

ppCommand (ShowText e)                  = psCommand "filltext" [ppExpr e]


ppValue :: Value -> Doc
ppValue (Int i)         = int i
ppValue (Float d)       = truncatedDouble $ realToFrac d
ppValue (String s)      = parens $ text s
ppValue (PsSymbol s)    = text ('/':s)
ppValue (Var s)         = text s



--------------------------------------------------------------------------------

type Code = H Stmt


program :: K.Program -> Mon Program
program (K.Program main_proc defs) = 
    Program <$> fundef1 main_proc <*> mapM fundef1 defs

fundef1 :: K.Fundef -> Mon Fundef
fundef1 (K.Fundef name _args body) = 
    (\h -> Fundef name (fromH h)) <$> expr1 body

expr1 :: K.Expr -> Mon Code
expr1 (K.Cmd cmd)   = (\c -> wrapH $ Command c) <$> command cmd
expr1 (e1 K.:>> e2) = appendH <$> expr1 e1 <*> expr1 e2

command :: K.Command -> Mon Command
command (K.NewPath)                     = pure NewPath
command (K.ClosePath)                   = pure ClosePath
command (K.Fill)                        = pure Fill
command (K.Stroke)                      = pure Stroke
command (K.MoveTo x y)                  = MoveTo <$> value x <*> value y
command (K.LineTo x y)                  = LineTo <$> value x <*> value y
command (K.CurveTo x1 y1 x2 y2 x3 y3)   = 
    CurveTo <$> value x1 <*> value y1 
            <*> value x2 <*> value y2
            <*> value x3 <*> value y3

command (K.GSave)                       = pure GSave
command (K.GRestore)                    = pure GRestore
command (K.Scale x y)                   = Scale <$> value x <*> value y
command (K.Rotate ang)                  = Rotate <$> value ang
command (K.Translate x y)               = Translate <$> value x <*> value y
command (K.Transform a b c d e f)       = 
    Transform <$> value a <*> value b <*> value c 
              <*> value d <*> value e <*> value f

command (K.ShowText v)                  = ShowText <$> value v


value :: K.Value -> Mon Expr
value (K.Unit)      = throwError $ "value1 applied to Unit"
value (K.Int i)     = pure $ Val $ Int i
value (K.Float d)   = pure $ Val $ Float d
value (K.String s)  = pure $ Val $ String s
value (K.Var vid)   = pure $ Val $ Var $ varName vid
